home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 5 / Apprentice-Release5.iso / Environments / Yerk 3.6.8 / tool+ / popUp7old < prev    next >
Encoding:
Text File  |  1994-12-08  |  5.4 KB  |  188 lines  |  [TEXT/MACA]
  1. :CLASS popUps <super Control 4 <indexed
  2.  
  3. \ late bound for subclasses to work - note that there can be no instances
  4. \  of this class..otherwise HANDLE: is recursive
  5.     :M  HANDLE: handle: [ ^base ] ;M
  6.  
  7.     :M  CTLHANDLE: get: ctlhndl ;M
  8.  
  9.     :M  GETCTLTITLE: ( -- addr len) ^base getTitle: control ;M
  10.  
  11.     \ ( cfa0...cfaN resid -- )  put resid and handlers in menu
  12.     :M  PUT:   put: resId  ^base put: array  ;M
  13.  
  14.     :M  PUTITEM: put: super ;M
  15.  
  16.     :M  GETITEM: ( -- item) get: super ;M
  17.  
  18.     :M  EXEC: ( part# --)
  19.         IF getItem: self -> mitem
  20.            ^base -> theMenu get: resID -> menuID
  21.             mitem 1- at: self execute exec: action
  22.             get: super put: myValue
  23.         THEN ;M
  24.  
  25.     \ ( item# -- addr len )  get string for item #
  26.     :M  GET:  ( item -- addr len ) handle: self  swap makeInt
  27.         buf255 +base  call GetItem  buf255 count ;M
  28.  
  29.     :M  GETTITLE: ( -- addr len) handle: self >ptr 14 + count ;M
  30.  
  31.     :M  GETNAME: ( -- addr len) getItem: self get: self ;M
  32.  
  33.     :M  GETMAXVAL: ( -- n) word0 ctlHandle: self call getCtlMax i->l ;M
  34.     :M  SETMAXVAL: ( n __) ctlHandle: self swap makeint call setCtlMax ;M
  35.  
  36.     \ ( addr len -- )  Append a menu item
  37.     :M  ADD:   Str255  handle: self ?new swap  call AppendMenu
  38.         getMaxVal: self 1+ setMaxVal: self ;M
  39.  
  40.     \ ( ind --) remove a menu item
  41.     :M  REMOVE: ( ind --) handle: self swap makeint call delMenuItem
  42.         getMaxVal: self 1- setMaxVal: self ;M
  43.  
  44.     \ ( addr len item# -- )  replace menu item string, but don't redraw
  45.     :M  (SET): alive: [ obj: myWindow ]
  46.         IF >r str255 >r handle: self ?new
  47.             r> r> swap >r makeInt r> call SetItem
  48.         ELSE 2drop drop
  49.         THEN ;M
  50.  
  51.     \ ( addr len item# -- )  replace menu item string and draw menu
  52.     :M  SET:  (set): self alive: [ obj: myWindow ]
  53.         IF  draw: super THEN ;M
  54.  
  55.     :M  (REDRAW): ( item --) dup 0= swap getItem: self = or IF draw: [ obj: myWindow ] THEN ;M
  56.  
  57.     \ ( item# -- )  Enable a menu item
  58.     :M  ENABLE: { item -- } handle: self item makeInt call EnableItem
  59.         item (redraw): self ;M
  60.  
  61.     \ ( item# -- )  Grey and disable an item
  62.     :M  DISABLE: { item -- } handle: self item makeInt call DisableItem
  63.         item (redraw): self ;M
  64.  
  65. \ return the number of items in the menu
  66.     :M  MITEMS: word0 handle: self call countMItems i->l ;M
  67.  
  68.     :M  CHECKED?: ( item -- b) ^base get: control = ;M
  69.  
  70.     :M  CLASSINIT: nullcfa fill: super nullcfa put: action ;M
  71.  
  72. ;CLASS
  73.  
  74.  
  75. :CLASS popUpMenu <super popUps
  76.  
  77.     rect bounds
  78.     int    valueParm
  79.  
  80.     :M  HANDLE: ptr: ctlhndl 28 + @ -base @ -base @ ;M
  81.  
  82.     :M  PUTRECT: put: bounds ;M
  83.  
  84. \ *** next three methods apply to the Title box, not the popup ***
  85.  
  86. \ 0=left;1=center;255=right
  87.     :M  JUSTIFY: ( n --) get: valueParm $ ff00 and or put: valueParm ;M
  88.  
  89. \ $100=bold;$200=italic;$400=underline;$800=outline;$1000=shadow
  90.     :M FACE: ( n --) get: valueParm $ e0ff and or put: valueParm ;M
  91.  
  92. \ $2000=condense;$4000=extend;$8000=nostyle
  93.     :M STYLE: ( n --) get: valueParm $ 1fff and or put: valueParm ;M
  94.  
  95. \ build a popup; procid is set to 1=fixedwidth;4=addresmen;8=useWFont
  96.     :M  NEW:  { x y addr len theWind \ tWid -- }
  97.         theWind saveFont
  98.         get: procID 8 and 0=
  99.         IF 0 tFont 12 tSize THEN addr len tWidth -> tWid    \ width of title
  100.         0 abs: theWind  Abs: bounds addr len str255
  101.         w 256 int: valueParm int: resId twid makeint  1008 get: procId +
  102.         makeInt  ^base
  103.         call NewControl put: ctlhndl
  104.         ^base get: ctlhndl set-ctl-obj
  105.         theWind put: myWindow theWind restFont ;M
  106.  
  107.       :M  GETNEW: { \ theWind -- } get: myWindow -> theWind
  108.          theWind 0= classerr" 190 theWind saveFont
  109.          0 int: resID theWind +base call getNewControl dup 0= classerr" 170
  110.          put: ctlhndl
  111.         ^base get: ctlhndl set-ctl-obj
  112.         get: myValue ^base put: control theWind restFont ;M
  113.  
  114. ;CLASS
  115.  
  116.  
  117. \ Example:
  118. \ ctlwind suz
  119. \ " .rsrc" openresfile
  120. \ 
  121. \ 5 popupmenu bob
  122. \ 100 50 160 69 putrect: bob
  123. \ 128 putresid: bob 8 init: bob
  124. \ example: suz
  125. \ 100 50 " myTitle:" suz new: bob
  126. \ 
  127. \ : one mitem home . ;
  128. \ 'c one fill: bob
  129. \ NB. When using PopUpDlgMenus in SaveDlg objects, know that the fill:
  130. \   method does not fill the instance variable 'myValue' of the control
  131. \   object. This means that even though the popup looks correct, if the
  132. \   user doesn't click in the menu, the ivar will not be filled. So access
  133. \   of the popup value by the getItem: method after the dialog is closed
  134. \   will not yield the correct number. For right now, must initialize each
  135. \   popup to the stored value of the saveDlg parameters by hand.
  136.  
  137. :CLASS popUpDlgMenu <super popUps
  138.  
  139.     int itemNo
  140.  
  141.     :M ITEMNo:     ( -- n)    get: itemNo ;M
  142.     :M PUTITEMNo: ( n --) put: itemNo ;M
  143.  
  144. \ returns handle to the control object, not the menu
  145. \ also, be careful...need to putItemNo: at compile time
  146.     :M CTLHANDLE: ( -- hndl) get: itemNo dup 0= classerr" 191
  147.         handle: [ obj: myWindow ] dup put: ctlhndl ;M
  148.  
  149.     :M HANDLE: ctlHandle: self >ptr 28 + @ -base @ -base @ ;M
  150.  
  151.     :M EXECACTION: handle: self drop get: itemNo get: [ obj: myWindow ] putItem: self
  152.         true exec: self returnToModal ;M
  153.  
  154.     :M SETITEM: ( --) ctlHandle: self drop getItem: self putItem: self ;M
  155.  
  156.     :M  GETNAME: ( -- addr len) setItem: self getItem: self get: self ;M
  157.  
  158. ;CLASS
  159.  
  160. \ Example:
  161. \ 3 savedlg bob1
  162. \ 402 putresid: bob1
  163. \ " .rsrc" openresfile
  164. \ 
  165. \ 5 popUpDlgMenu suz1
  166. \ 402 putresid: suz1
  167. \ bob1 putWindow: suz1
  168. \ 
  169. \ : uu " .rsrc" openresfile getnew: bob1 modal: bob1 ;
  170. \ 
  171. \ 'c returnToModal 2 to: bob1
  172. \ 
  173. \ 0 value huh
  174. \ : ll handle: suz1 drop get: theItem get: bob1 putItem: suz1
  175. \     true exec: suz1 returnToModal ;
  176. \ : ll execAction: suz1 ;
  177. \ : dosave save: bob1 closer ;
  178. \ 'c dosave 1 to: bob1
  179. \ 'c ll 2 to: bob1
  180. \ 
  181. \ : one1 1 ++> huh ;
  182. \ : two 2 ++> huh ;
  183. \ : three 3 ++> huh ;
  184. \ : four 4 ++> huh ;
  185. \ : five 5 ++> huh ;
  186. \ 
  187. \ 5 'cfas one1 two three four five 400 put: suz1
  188.